VERSION 5.00
Begin VB.Form frmMain 
   BackColor       =   &H00000000&
   BorderStyle     =   0  'None
   Caption         =   "John's Jumping GL Cube"
   ClientHeight    =   5535
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   7770
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   369
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   518
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.CommandButton Command1 
      Appearance      =   0  'Flat
      BackColor       =   &H00000000&
      Caption         =   "Exit"
      Height          =   285
      Left            =   45
      MaskColor       =   &H00FF0000&
      TabIndex        =   0
      Top             =   30
      Width           =   1650
   End
   Begin VB.Timer Timer1 
      Interval        =   1
      Left            =   120
      Top             =   360
   End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Some of this code was created by some unknown person, i downloaded it from the net somewhere,
' i do not claim to have written the complete code to this program. But i have made plenty of modifications, which basically
' makes this code my own, only about 10% is somebody elses, mainly the Init of GL.
' Any problems with this code, email me at the following address:
' John@john-obrien.freeserve.co.uk
' Copyright (C) 1999 John O'Brien (Yeah right, i couldn't copyright this code if i tried,
' because the code is too generic, everybody uses it)
' Although i have copyrighted this source code and program, you are free to modify, change, hack,
' learn from, this code and program (that's the idea, and besides i can't stop you!)
' Happy coding and i hope this helps you on your journey to become a better OpenGL programmer......
Option Explicit
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function ChoosePixelFormat Lib "gdi32" (ByVal hDC As Long, pfd As PIXELFORMATDESCRIPTOR) As Long
Private Declare Function CreatePalette Lib "gdi32" (pPal As LOGPALETTE) As Long
Private Declare Sub DeleteObject Lib "gdi32" (hObject As Long)
Private Declare Sub DescribePixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal PixelFormat As Long, ByVal nBytes As Long, pfd As PIXELFORMATDESCRIPTOR)
Private Declare Function GetDC Lib "gdi32" (ByVal hWnd As Long) As Long
Private Declare Function GetPixelFormat Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal start As Long, ByVal entries As Long, ByVal ptrEntries As Long)
Private Declare Sub RealizePalette Lib "gdi32" (ByVal hPalette As Long)
Private Declare Sub SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bln As Long)
Private Declare Function SetPixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal i As Long, pfd As PIXELFORMATDESCRIPTOR) As Boolean
Private Declare Sub SwapBuffers Lib "gdi32" (ByVal hDC As Long)
Private Declare Function wglCreateContext Lib "OpenGL32" (ByVal hDC As Long) As Long
Private Declare Sub wglDeleteContext Lib "OpenGL32" (ByVal hContext As Long)
Private Declare Sub wglMakeCurrent Lib "OpenGL32" (ByVal l1 As Long, ByVal l2 As Long)
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(0 To 255) As PALETTEENTRY
End Type
Private Type PIXELFORMATDESCRIPTOR
    nSize As Integer
    nVersion As Integer
    dwFlags As Long
    iPixelType As Byte
    cColorBits As Byte
    cRedBits As Byte
    cRedShift As Byte
    cGreenBits As Byte
    cGreenShift As Byte
    cBlueBits As Byte
    cBlueShift As Byte
    cAlphaBits As Byte
    cAlphaShift As Byte
    cAccumBits As Byte
    cAccumRedBits As Byte
    cAccumGreenBits As Byte
    cAccumBlueBits As Byte
    cAccumAlpgaBits As Byte
    cDepthBits As Byte
    cStencilBits As Byte
    cAuxBuffers As Byte
    iLayerType As Byte
    bReserved As Byte
    dwLayerMask As Long
    dwVisibleMask As Long
    dwDamageMask As Long
End Type
Const PFD_TYPE_RGBA = 0
Const PFD_TYPE_COLORINDEX = 1
Const PFD_MAIN_PLANE = 0
Const PFD_DOUBLEBUFFER = 1
Const PFD_DRAW_TO_WINDOW = &H4
Const PFD_SUPPORT_OPENGL = &H20
Const PFD_NEED_PALETTE = &H80
Dim hPalette As Long
Dim hGLRC As Long
Dim xAngle As GLfloat
Dim yAngle As GLfloat
Dim zAngle As GLfloat
Dim doubleBuffer As GLboolean
Dim displayListInited As GLboolean
                  
Dim MatSpecular(3) As GLfloat
Dim MatShininess(0) As GLfloat
Dim LightPosition(3) As GLfloat
Dim pPos As Long
Dim lasty As Single
Dim i As Long
Sub MyInit()
    MatSpecular(0) = 1
    MatSpecular(1) = 1
    MatSpecular(2) = 1
    MatSpecular(3) = 1
    MatShininess(0) = 50
    LightPosition(0) = 1
    LightPosition(1) = 1
    LightPosition(2) = 1
    LightPosition(3) = 0
    glMaterialfv GL_FRONT, GL_SPECULAR, MatSpecular(0)
    glMaterialfv GL_FRONT, GL_SHININESS, MatShininess(0)
    glLightfv GL_LIGHT0, GL_POSITION, LightPosition(0)
    glEnable GL_LIGHTING
    glEnable GL_LIGHT0
    glDepthFunc GL_LESS
    glEnable GL_DEPTH_TEST
End Sub
Private Sub TEMP()
glColor4i 250, 0, 0, 0
        glVertex4i -1, 1, 1, 1
        glVertex4i 1, -1, 1, -1
        glVertex4i -1, 1, -1, 1
        glVertex4i 1, -1, 1, 1
       
       glColor4i 0, 250, 0, 150
        glVertex4i 1, -1, -1, -1
        glVertex4i -1, 1, -1, 1
        glVertex4i 1, -1, 1, -1
        glVertex4i -1, 1, -1, -1
 glColor4i 0, 250, 0, 150
        glVertex4i -1, 1, 1, -1
        glVertex4i 1, -1, 1, -1
        glVertex4i -1, 1, -1, 1
        glVertex4i 1, -1, -1, 1
 glColor4i 0, 250, 0, 150
        glVertex4i 1, 1, -1, -1
        glVertex4i -1, 1, -1, 1
        glVertex4i 1, 1, 1, -1
        glVertex4i -1, 1, 1, -1
'Me.Show
End Sub
Sub FatalError(ByVal strMessage As String)
'Error handler, used when something goes wrong, to exit.
    MsgBox "Fatal Error: " & strMessage, vbCritical + vbApplicationModal + vbOKOnly + vbDefaultButton1, "Fatal Error In " & App.Title
    Unload frmMain
    Set frmMain = Nothing
    End
End Sub
Sub SetupPixelFormat(ByVal hDC As Long)
'Retrieve/set a Win32 pixel format for OpenGL modes with double-
'buffering, and direct draw to window with RGBA color mode.
'16bit (65536 colors) depth is preferable.
    Dim pfd As PIXELFORMATDESCRIPTOR
    Dim PixelFormat As Integer
    pfd.nSize = Len(pfd)
    pfd.nVersion = 1
    pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW Or PFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
    pfd.iPixelType = PFD_TYPE_RGBA
    pfd.cColorBits = 16
    pfd.cDepthBits = 16
    pfd.iLayerType = PFD_MAIN_PLANE
    PixelFormat = ChoosePixelFormat(hDC, pfd)
    If PixelFormat = 0 Then FatalError "Could not retrieve pixel format!"
    SetPixelFormat hDC, PixelFormat, pfd
End Sub
Sub SetupPalette(ByVal lhDC As Long)
' Initialize the Win32 form pallete.
    Dim PixelFormat As Long
    Dim pfd As PIXELFORMATDESCRIPTOR
    Dim pPal As LOGPALETTE
    Dim PaletteSize As Long
    PixelFormat = GetPixelFormat(lhDC)
    DescribePixelFormat lhDC, PixelFormat, Len(pfd), pfd
    If (pfd.dwFlags And PFD_NEED_PALETTE) <> 0 Then
        PaletteSize = 2 ^ pfd.cColorBits
    Else
        Exit Sub
    End If
    pPal.palVersion = &H300
    pPal.palNumEntries = PaletteSize
    Dim redMask As Long
    Dim GreenMask As Long
    Dim BlueMask As Long
    Dim i As Long
    redMask = 2 ^ pfd.cRedBits - 1
    GreenMask = 2 ^ pfd.cGreenBits - 1
    BlueMask = 2 ^ pfd.cBlueBits - 1
    For i = 0 To PaletteSize - 1
        With pPal.palPalEntry(i)
            .peRed = i
            .peGreen = i
            .peBlue = i
            .peFlags = 0
        End With
    Next
    GetSystemPaletteEntries hDC, 0, 256, VarPtr(pPal.palPalEntry(0))
    hPalette = CreatePalette(pPal)
    If hPalette <> 0 Then
        SelectPalette lhDC, hPalette, False
        RealizePalette lhDC
    End If
End Sub
Private Sub Command1_Click()
End Sub
Private Sub Form_Load()
    xAngle = 42
    yAngle = 82
    zAngle = 112
    doubleBuffer = GL_TRUE
    displayListInited = GL_FALSE
    SetupPixelFormat hDC
    hGLRC = wglCreateContext(hDC)
    wglMakeCurrent hDC, hGLRC
    glEnable GL_DEPTH_TEST
    glEnable GL_DITHER
    glDepthFunc GL_LESS
    glClearDepth 1
    glClearColor 0, 0, 0, 0
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    glFrustum -1, 1, -1, 1, 1, 10
    glViewport 0, 0, 600, 600
    displayListInited = GL_FALSE
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0, 0, -3
    Form_Paint
End Sub
Private Sub Form_Paint()
'If a display list has been created, use it.  Otherwise, create it.
 If displayListInited = GL_TRUE Then
        glCallList 1
 Else
 glNewList 1, GL_COMPILE_AND_EXECUTE
 glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
 glBegin GL_QUADS
 glEnable GL_LIGHTING
'Setup the Cube ready for drawing
        glColor3f 0, 1, 0               ' Front Face (Green)
        glVertex3f -1, 1, 1
        glVertex3f 1, 1, 1
        glVertex3f 1, -1, 1
        glVertex3f -1, -1, 1
        
        glColor3f 0, 1, 0               ' Back Face (Yellow)
        glVertex3f -1, 1, -1
        glVertex3f 1, 1, -1
        glVertex3f 1, -1, -1
        glVertex3f -1, -1, -1
        
        glColor3f 0, 0, 1               ' Top Side Face (Blue)
        glVertex3f -1, 1, 1
        glVertex3f 1, 1, 1
        glVertex3f 1, 1, -1
        glVertex3f -1, 1, -1
        
        glColor3f 0, 0, 1               ' Bottom Side Face (Red)
        glVertex3f -1, -1, 1
        glVertex3f 1, -1, 1
        glVertex3f 1, -1, -1
        glVertex3f -1, -1, -1
        
        glColor3f 1, 0, 0               ' Left Face (Yellow)
         glVertex3f -1, -1, -1
        glVertex3f -1, -1, 1
        glVertex3f -1, 1, 1
        glVertex3f -1, 1, -1
       
        glColor3f 1, 0, 0               ' right Face (Yellow)
        glVertex3f 1, -1, -1
        glVertex3f 1, -1, 1
        glVertex3f 1, 1, 1
        glVertex3f 1, 1, -1
        glEnd
        glEndList
        displayListInited = GL_TRUE
    End If
    SwapBuffers hDC
        
End Sub
Private Sub Form_Resize()
' Resize the OpenGL view if the form resizes, and redraw.
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Release OpenGL if we decide to quit.
    If hGLRC <> 0 Then
        wglMakeCurrent 0, 0
        wglDeleteContext hGLRC
    End If
    If hPalette <> 0 Then
        DeleteObject hPalette
    End If
End Sub
Private Sub Timer1_Timer()
' Rotate the Cube (Animation)
Dim Ang
Ang = Ang + 2
glRotatef -Ang, 0, 1, 1
Form_Paint
End Sub